{
  Copyright 2012 Sergey Ostanin

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
}

unit OrderQuestion;

interface

uses
  Classes, SysUtils, MiscUtils, Math, TestCore, SecureRandom, Pad, TestUtils;

type
  TOrderResponse = class(TResponse)
  private
    FAnswer: TIntegerArray;
  public
    procedure SetAnswer(const Value: TIntegerArray);
    function GetAnswer: TIntegerArray;
    procedure Assign(Source: TResponse); override;
  end;

  TOrderQuestion = class(TQuestionWithFormulation)
  private
    FItems: TPadGroup;
    FDistractors: TPadGroup;
    FItemLimit: Integer; { 0 = all }
    FDistractorLimit: Integer; { 0 = all }
    procedure SetItemLimit(Value: Integer);
    procedure SetDistractorLimit(Value: Integer);
  public
    constructor Create; override;
    destructor Destroy; override;
    class function GetResponseClass: TResponseClass; override;
    class procedure Spawn(var Question: TQuestion; Alterants: TAlterantList); override;
    class function Kind: TKind; override;
    procedure Filter; override;
    function IsResponseCompatible(Candidate: TResponse): Boolean; override;
    function Evaluate(Candidate: TResponse): Single; override;
    procedure Assign(Source: TQuestion); override;
    function ReplaceString(const OldString, NewString: String): Integer; override;
    function Response: TOrderResponse;

    property DistractorLimit: Integer read FDistractorLimit write SetDistractorLimit;
    property Distractors: TPadGroup read FDistractors;
    property ItemLimit: Integer read FItemLimit write SetItemLimit;
    property Items: TPadGroup read FItems;
  end;

  TSpawnOrderQuestionAlterant = class(TAlterant)
  private
    FPlacement: TIntegerArray;
  public
    procedure Apply(var Question: TQuestion); override;
    function GetPlacement: TIntegerArray;
    procedure SetPlacement(const Placement: TIntegerArray);
  end;

implementation

type
  TOfferedItem = class
  private
    FDisplayIndex: Integer;
    FItemIndex: Integer; { negative for distractors }
  public
    constructor Create(DisplayIndex, ItemIndex: Integer);
  end;
  TOfferedItemList = TGenericObjectList<TOfferedItem>;

function Kendall(const a: array of Integer): Double;
var
  i, j, Len, v: Integer;
  c: Int64; { number of correctly ordered pairs }
  s: Int64; { total number of pairs }
begin
  Len := Length(a);
  if Len >= 2 then
  begin
    c := 0;
    for i := 0 to Len-2 do
    begin
      v := a[i];
      for j := i+1 to Len-1 do
        if v < a[j] then
          Inc(c);
    end;
    {$HINTS OFF}
    s := Int64(Len) * (Len-1) div 2;
    {$HINTS ON}
    Result := (2*c - s) / s;
  end
  else
    Result := 0;
end;

{ TOfferedItem }

constructor TOfferedItem.Create(DisplayIndex, ItemIndex: Integer);
begin
  inherited Create;
  FDisplayIndex := DisplayIndex;
  FItemIndex := ItemIndex;
end;

{ TOrderResponse }

function TOrderResponse.GetAnswer: TIntegerArray;
begin
  Result := Copy(FAnswer);
end;

procedure TOrderResponse.Assign(Source: TResponse);
begin
  inherited;
  FAnswer := Copy((Source as TOrderResponse).FAnswer);
  Changed;
end;

procedure TOrderResponse.SetAnswer(const Value: TIntegerArray);
begin
  FAnswer := Copy(Value);
  Changed;
end;

{ TOrderQuestion }

constructor TOrderQuestion.Create;
begin
  inherited;
  FItems := TPadGroup.Create;
  FDistractors := TPadGroup.Create;
end;

destructor TOrderQuestion.Destroy;
begin
  FreeAndNil(FItems);
  FreeAndNil(FDistractors);
  inherited;
end;

procedure TOrderQuestion.Filter;
var
  i: Integer;
  NullAnswer: TIntegerArray;
begin
  inherited;
  SetLength(NullAnswer, Length(Response.GetAnswer));
  for i := 0 to High(NullAnswer) do
    NullAnswer[i] := -1;
  Response.SetAnswer(NullAnswer);

  ItemLimit := 0;
  DistractorLimit := 0;
end;

procedure TOrderQuestion.Assign(Source: TQuestion);
var
  q: TOrderQuestion;
begin
  inherited;
  q := Source as TOrderQuestion;

  FItems.Assign(q.FItems);
  FItemLimit := q.FItemLimit;

  FDistractors.Assign(q.FDistractors);
  FDistractorLimit := q.FDistractorLimit;
end;

function TOrderQuestion.Response: TOrderResponse;
begin
  Result := TOrderResponse(inherited);
end;

class function TOrderQuestion.GetResponseClass: TResponseClass;
begin
  Result := TOrderResponse;
end;

procedure TOrderQuestion.SetDistractorLimit(Value: Integer);
begin
  Assert( Value >= 0 );
  FDistractorLimit := Value;
end;

procedure TOrderQuestion.SetItemLimit(Value: Integer);
begin
  Assert( Value >= 0 );
  FItemLimit := Value;
end;

function TOrderQuestion.ReplaceString(const OldString,
  NewString: String): Integer;
begin
  Result := inherited;
  Inc(Result, FItems.ReplaceString(OldString, NewString));
  Inc(Result, FDistractors.ReplaceString(OldString, NewString));
end;

class procedure TOrderQuestion.Spawn(var Question: TQuestion;
  Alterants: TAlterantList);
var
  Alterant: TSpawnOrderQuestionAlterant;
  List: TIntegerList;
  i, ItemsUsed, DistractorsUsed, FirstDistractorIndex: Integer;
  OrderQuestion: TOrderQuestion;
  Placement: TIntegerArray;
begin
  inherited;
  Assert( Question is TOrderQuestion );
  OrderQuestion := TOrderQuestion(Question);
  Alterant := TSpawnOrderQuestionAlterant.Create;
  Alterants.Add(Alterant);

  List := TIntegerList.Create;
  try
    for i := 0 to OrderQuestion.FItems.Count-1 do
      List.Add(i);
    if OrderQuestion.FItemLimit = 0 then
      ItemsUsed := OrderQuestion.FItems.Count
    else
      ItemsUsed := Min(OrderQuestion.FItemLimit, OrderQuestion.FItems.Count);
    for i := 1 to OrderQuestion.FItems.Count - ItemsUsed do
      List.Delete(SecureRandomInteger(List.Count));

    FirstDistractorIndex := List.Count;
    for i := 0 to OrderQuestion.FDistractors.Count-1 do
      List.Add(-(i+1));
    if OrderQuestion.FDistractorLimit = 0 then
      DistractorsUsed := OrderQuestion.FDistractors.Count
    else
      DistractorsUsed := Min(OrderQuestion.FDistractorLimit, OrderQuestion.FDistractors.Count);
    for i := 1 to OrderQuestion.FDistractors.Count - DistractorsUsed do
      List.Delete(SecureRandomInteger(List.Count - FirstDistractorIndex) + FirstDistractorIndex);

    ShuffleList(List, SecureRandomInteger);

    SetLength(Placement, List.Count);
    for i := 0 to List.Count-1 do
      Placement[i] := List[i];
    Alterant.SetPlacement(Placement);
  finally
    List.Free;
  end;

  Alterant.Apply(Question);
end;

class function TOrderQuestion.Kind: TKind;
begin
  Result := $1c5a9f1c3ce16fd9;
end;

function TOrderQuestion.IsResponseCompatible(
  Candidate: TResponse): Boolean;
var
  Answer: TIntegerArray;
  ItemUsed: array of Boolean;
  i, n: Integer;
begin
  Result := Candidate is TOrderResponse;
  if Result then
  begin
    Answer := TOrderResponse(Candidate).GetAnswer;
    Result := Length(Answer) = Length(Response.GetAnswer);
    if Result then
    begin
      SetLength(ItemUsed, Items.Count);
      for i := 0 to High(ItemUsed) do
        ItemUsed[i] := FALSE;

      for i := 0 to High(Answer) do
      begin
        n := Answer[i];
        if (n < -1) or (n >= Items.Count) then
        begin
          Result := FALSE;
          Break;
        end
        else if n >= 0 then
        begin
          if ItemUsed[n] then
          begin
            Result := FALSE;
            Break;
          end
          else
            ItemUsed[n] := TRUE;
        end;
      end;
    end;
  end;
end;

function TOrderQuestion.Evaluate(Candidate: TResponse): Single;
var
  CandidateAnswer, RightAnswer: TIntegerArray;
  n, m: Integer;
  p: Integer; { number of sequence items in the respondent's answer }
  t: Integer; { number of distractors in the respondent's answer }
  q: Integer; { number of items in the correct answer, p <= q;
    q - (p+t) - number of blanks in the respondent's answer }
  Indices: array of Integer; { RightAnswer indices of the sequence items
    in the respondent's answer }
begin
  CheckResponseCompatible(Candidate);
  CandidateAnswer := TOrderResponse(Candidate).GetAnswer;
  if LaxEvaluation then
  begin
    RightAnswer := Response.GetAnswer;
    Assert( Length(RightAnswer) = Length(CandidateAnswer) );

    Indices := nil;
    t := 0;
    for n in CandidateAnswer do
    begin
      if n <> -1 then
      begin
        m := FindArrayInteger(RightAnswer, n);
        if m <> -1 then
        begin
          SetLength(Indices, Length(Indices)+1);
          Indices[High(Indices)] := m;
        end
        else
          Inc(t);
      end;
    end;

    p := Length(Indices);
    q := Length(RightAnswer);
    if q = 0 then
      Result := 1
    else if q = 1 then
    begin
      Assert( (p = 0) or (p = 1) );
      Result := p;
    end
    else
    begin
      if p <= 1 then
        Result := 0
      else
      begin
        { q >= 2, p >= 2 }
        if p <= t then
          Result := 0
        else
          Result := Sqr(Max(Kendall(Indices), 0) * (p-t) / q);
      end;
    end;
  end
  else
    Result := EvaluateMappingDichotomically(Response.GetAnswer, CandidateAnswer);
end;

{ TSpawnOrderQuestionAlterant }

function CompareItemIndices(const a, b: TOfferedItem): Integer;
begin
  Result := CompareIntegers(a.FItemIndex, b.FItemIndex);
end;

procedure TSpawnOrderQuestionAlterant.Apply(var Question: TQuestion);
var
  OrderQuestion: TOrderQuestion;
  Answer: TIntegerArray;
  i, n, DistractorCount: Integer;
  NewSequence: TPadGroup;
  Item: TPad;
  Items: TOfferedItemList;
  OfferedItem: TOfferedItem;
begin
  Assert( Question is TOrderQuestion );
  OrderQuestion := TOrderQuestion(Question);

  NewSequence := TPadGroup.Create;
  try
    for i := 0 to High(FPlacement) do
    begin
      Item := TPad.Create;
      NewSequence.Add(Item);
      n := FPlacement[i];
      if n >= 0 then
        Item.Assign(OrderQuestion.Items[n])
      else
        Item.Assign(OrderQuestion.Distractors[-n-1]);
    end;
    OrderQuestion.Items.Assign(NewSequence);
  finally
    NewSequence.Free;
  end;
  OrderQuestion.Distractors.Clear;

  Items := TOfferedItemList.Create;
  try
    for i := 0 to High(FPlacement) do
      Items.AddSafely(TOfferedItem.Create(i, FPlacement[i]));

    Items.Sort(CompareItemIndices);

    DistractorCount := 0;
    for OfferedItem in Items do
      if OfferedItem.FItemIndex < 0 then
        Inc(DistractorCount)
      else
        Break;

    SetLength(Answer, Items.Count - DistractorCount);
    for i := 0 to High(Answer) do
      Answer[i] := Items[DistractorCount + i].FDisplayIndex;
    OrderQuestion.Response.SetAnswer(Answer);
  finally
    Items.Free;
  end;
end;

function TSpawnOrderQuestionAlterant.GetPlacement: TIntegerArray;
begin
  Result := Copy(FPlacement);
end;

procedure TSpawnOrderQuestionAlterant.SetPlacement(
  const Placement: TIntegerArray);
begin
  FPlacement := Copy(Placement);
end;

end.
